home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / harvest.cpt / Harvest C / Tcl 6.2 / tclCmdAH.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-04-12  |  21.4 KB  |  905 lines
  1. #ifdef macintosh
  2. #    pragma segment tclCmdAH
  3. #endif
  4.  
  5. /* 
  6.  * tclCmdAH.c --
  7.  *
  8.  *    This file contains the top-level command routines for most of
  9.  *    the Tcl built-in commands whose names begin with the letters
  10.  *    A to H.
  11.  *
  12.  * Copyright 1987-1991 Regents of the University of California
  13.  * Permission to use, copy, modify, and distribute this
  14.  * software and its documentation for any purpose and without
  15.  * fee is hereby granted, provided that the above copyright
  16.  * notice appear in all copies.  The University of California
  17.  * makes no representations about the suitability of this
  18.  * software for any purpose.  It is provided "as is" without
  19.  * express or implied warranty.
  20.  */
  21.  
  22. #ifndef lint
  23. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.73 91/11/07 09:02:11 ouster Exp $ SPRITE (Berkeley)";
  24. #endif
  25.  
  26. #include "tclInt.h"
  27.  
  28.  
  29. /*
  30.  *----------------------------------------------------------------------
  31.  *
  32.  * Tcl_BreakCmd --
  33.  *
  34.  *    This procedure is invoked to process the "break" Tcl command.
  35.  *    See the user documentation for details on what it does.
  36.  *
  37.  * Results:
  38.  *    A standard Tcl result.
  39.  *
  40.  * Side effects:
  41.  *    See the user documentation.
  42.  *
  43.  *----------------------------------------------------------------------
  44.  */
  45.  
  46.     /* ARGSUSED */
  47. int
  48. Tcl_BreakCmd(dummy, interp, argc, argv)
  49.     ClientData dummy;            /* Not used. */
  50.     Tcl_Interp *interp;            /* Current interpreter. */
  51.     int argc;                /* Number of arguments. */
  52.     char **argv;            /* Argument strings. */
  53. {
  54.     if (argc != 1) {
  55.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  56.         argv[0], "\"", (char *) NULL);
  57.     return TCL_ERROR;
  58.     }
  59.     return TCL_BREAK;
  60. }
  61.  
  62. /*
  63.  *----------------------------------------------------------------------
  64.  *
  65.  * Tcl_CaseCmd --
  66.  *
  67.  *    This procedure is invoked to process the "case" Tcl command.
  68.  *    See the user documentation for details on what it does.
  69.  *
  70.  * Results:
  71.  *    A standard Tcl result.
  72.  *
  73.  * Side effects:
  74.  *    See the user documentation.
  75.  *
  76.  *----------------------------------------------------------------------
  77.  */
  78.  
  79.     /* ARGSUSED */
  80. int
  81. Tcl_CaseCmd(dummy, interp, argc, argv)
  82.     ClientData dummy;            /* Not used. */
  83.     Tcl_Interp *interp;            /* Current interpreter. */
  84.     int argc;                /* Number of arguments. */
  85.     char **argv;            /* Argument strings. */
  86. {
  87.     int i, result;
  88.     int body;
  89.     char *string;
  90.     int caseArgc, splitArgs;
  91.     char **caseArgv;
  92.  
  93.     if (argc < 3) {
  94.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  95.         argv[0], " string ?in? patList body ... ?default body?\"",
  96.         (char *) NULL);
  97.     return TCL_ERROR;
  98.     }
  99.     string = argv[1];
  100.     body = -1;
  101.     if (strcmp(argv[2], "in") == 0) {
  102.     i = 3;
  103.     } else {
  104.     i = 2;
  105.     }
  106.     caseArgc = argc - i;
  107.     caseArgv = argv + i;
  108.  
  109.     /*
  110.      * If all of the pattern/command pairs are lumped into a single
  111.      * argument, split them out again.
  112.      */
  113.  
  114.     splitArgs = 0;
  115.     if (caseArgc == 1) {
  116.     result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
  117.     if (result != TCL_OK) {
  118.         return result;
  119.     }
  120.     splitArgs = 1;
  121.     }
  122.  
  123.     for (i = 0; i < caseArgc; i += 2) {
  124.     int patArgc, j;
  125.     char **patArgv;
  126.     register char *p;
  127.  
  128.     if (i == (caseArgc-1)) {
  129.         interp->result = "extra case pattern with no body";
  130.         result = TCL_ERROR;
  131.         goto cleanup;
  132.     }
  133.  
  134.     /*
  135.      * Check for special case of single pattern (no list) with
  136.      * no backslash sequences.
  137.      */
  138.  
  139.     for (p = caseArgv[i]; *p != 0; p++) {
  140.         if (isspace(*p) || (*p == '\\')) {
  141.         break;
  142.         }
  143.     }
  144.     if (*p == 0) {
  145.         if ((*caseArgv[i] == 'd')
  146.             && (strcmp(caseArgv[i], "default") == 0)) {
  147.         body = i+1;
  148.         }
  149.         if (Tcl_StringMatch(string, caseArgv[i])) {
  150.         body = i+1;
  151.         goto match;
  152.         }
  153.         continue;
  154.     }
  155.  
  156.     /*
  157.      * Break up pattern lists, then check each of the patterns
  158.      * in the list.
  159.      */
  160.  
  161.     result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
  162.     if (result != TCL_OK) {
  163.         goto cleanup;
  164.     }
  165.     for (j = 0; j < patArgc; j++) {
  166.         if (Tcl_StringMatch(string, patArgv[j])) {
  167.         body = i+1;
  168.         break;
  169.         }
  170.     }
  171.     ckfree((char *) patArgv);
  172.     if (j < patArgc) {
  173.         break;
  174.     }
  175.     }
  176.  
  177.     match:
  178.     if (body != -1) {
  179.     result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL);
  180.     if (result == TCL_ERROR) {
  181.         char msg[100];
  182.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[i],
  183.             interp->errorLine);
  184.         Tcl_AddErrorInfo(interp, msg);
  185.     }
  186.     goto cleanup;
  187.     }
  188.  
  189.     /*
  190.      * Nothing matched:  return nothing.
  191.      */
  192.  
  193.     result = TCL_OK;
  194.  
  195.     cleanup:
  196.     if (splitArgs) {
  197.     ckfree((char *) caseArgv);
  198.     }
  199.     return result;
  200. }
  201.  
  202. /*
  203.  *----------------------------------------------------------------------
  204.  *
  205.  * Tcl_CatchCmd --
  206.  *
  207.  *    This procedure is invoked to process the "catch" Tcl command.
  208.  *    See the user documentation for details on what it does.
  209.  *
  210.  * Results:
  211.  *    A standard Tcl result.
  212.  *
  213.  * Side effects:
  214.  *    See the user documentation.
  215.  *
  216.  *----------------------------------------------------------------------
  217.  */
  218.  
  219.     /* ARGSUSED */
  220. int
  221. Tcl_CatchCmd(dummy, interp, argc, argv)
  222.     ClientData dummy;            /* Not used. */
  223.     Tcl_Interp *interp;            /* Current interpreter. */
  224.     int argc;                /* Number of arguments. */
  225.     char **argv;            /* Argument strings. */
  226. {
  227.     int result;
  228.  
  229.     if ((argc != 2) && (argc != 3)) {
  230.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  231.         argv[0], " command ?varName?\"", (char *) NULL);
  232.     return TCL_ERROR;
  233.     }
  234.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  235.     if (argc == 3) {
  236.     if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
  237.         Tcl_SetResult(interp, "couldn't save command result in variable",
  238.             TCL_STATIC);
  239.         return TCL_ERROR;
  240.     }
  241.     }
  242.     Tcl_ResetResult(interp);
  243.     sprintf(interp->result, "%d", result);
  244.     return TCL_OK;
  245. }
  246.  
  247. /*
  248.  *----------------------------------------------------------------------
  249.  *
  250.  * Tcl_ConcatCmd --
  251.  *
  252.  *    This procedure is invoked to process the "concat" Tcl command.
  253.  *    See the user documentation for details on what it does.
  254.  *
  255.  * Results:
  256.  *    A standard Tcl result.
  257.  *
  258.  * Side effects:
  259.  *    See the user documentation.
  260.  *
  261.  *----------------------------------------------------------------------
  262.  */
  263.  
  264.     /* ARGSUSED */
  265. int
  266. Tcl_ConcatCmd(dummy, interp, argc, argv)
  267.     ClientData dummy;            /* Not used. */
  268.     Tcl_Interp *interp;            /* Current interpreter. */
  269.     int argc;                /* Number of arguments. */
  270.     char **argv;            /* Argument strings. */
  271. {
  272.     if (argc == 1) {
  273.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  274.         " arg ?arg ...?\"", (char *) NULL);
  275.     return TCL_ERROR;
  276.     }
  277.  
  278.     interp->result = Tcl_Concat(argc-1, argv+1);
  279.     interp->freeProc = (Tcl_FreeProc *) free;
  280.     return TCL_OK;
  281. }
  282.  
  283. /*
  284.  *----------------------------------------------------------------------
  285.  *
  286.  * Tcl_ContinueCmd --
  287.  *
  288.  *    This procedure is invoked to process the "continue" Tcl command.
  289.  *    See the user documentation for details on what it does.
  290.  *
  291.  * Results:
  292.  *    A standard Tcl result.
  293.  *
  294.  * Side effects:
  295.  *    See the user documentation.
  296.  *
  297.  *----------------------------------------------------------------------
  298.  */
  299.  
  300.     /* ARGSUSED */
  301. int
  302. Tcl_ContinueCmd(dummy, interp, argc, argv)
  303.     ClientData dummy;            /* Not used. */
  304.     Tcl_Interp *interp;            /* Current interpreter. */
  305.     int argc;                /* Number of arguments. */
  306.     char **argv;            /* Argument strings. */
  307. {
  308.     if (argc != 1) {
  309.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  310.         "\"", (char *) NULL);
  311.     return TCL_ERROR;
  312.     }
  313.     return TCL_CONTINUE;
  314. }
  315.  
  316. /*
  317.  *----------------------------------------------------------------------
  318.  *
  319.  * Tcl_ErrorCmd --
  320.  *
  321.  *    This procedure is invoked to process the "error" Tcl command.
  322.  *    See the user documentation for details on what it does.
  323.  *
  324.  * Results:
  325.  *    A standard Tcl result.
  326.  *
  327.  * Side effects:
  328.  *    See the user documentation.
  329.  *
  330.  *----------------------------------------------------------------------
  331.  */
  332.  
  333.     /* ARGSUSED */
  334. int
  335. Tcl_ErrorCmd(dummy, interp, argc, argv)
  336.     ClientData dummy;            /* Not used. */
  337.     Tcl_Interp *interp;            /* Current interpreter. */
  338.     int argc;                /* Number of arguments. */
  339.     char **argv;            /* Argument strings. */
  340. {
  341.     Interp *iPtr = (Interp *) interp;
  342.  
  343.     if ((argc < 2) || (argc > 4)) {
  344.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  345.         " message ?errorInfo? ?errorCode?\"", (char *) NULL);
  346.     return TCL_ERROR;
  347.     }
  348.     if ((argc >= 3) && (argv[2][0] != 0)) {
  349.     Tcl_AddErrorInfo(interp, argv[2]);
  350.     iPtr->flags |= ERR_ALREADY_LOGGED;
  351.     }
  352.     if (argc == 4) {
  353.     Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
  354.         TCL_GLOBAL_ONLY);
  355.     iPtr->flags |= ERROR_CODE_SET;
  356.     }
  357.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  358.     return TCL_ERROR;
  359. }
  360.  
  361. /*
  362.  *----------------------------------------------------------------------
  363.  *
  364.  * Tcl_EvalCmd --
  365.  *
  366.  *    This procedure is invoked to process the "eval" Tcl command.
  367.  *    See the user documentation for details on what it does.
  368.  *
  369.  * Results:
  370.  *    A standard Tcl result.
  371.  *
  372.  * Side effects:
  373.  *    See the user documentation.
  374.  *
  375.  *----------------------------------------------------------------------
  376.  */
  377.  
  378.     /* ARGSUSED */
  379. int
  380. Tcl_EvalCmd(dummy, interp, argc, argv)
  381.     ClientData dummy;            /* Not used. */
  382.     Tcl_Interp *interp;            /* Current interpreter. */
  383.     int argc;                /* Number of arguments. */
  384.     char **argv;            /* Argument strings. */
  385. {
  386.     int result;
  387.     char *cmd;
  388.  
  389.     if (argc < 2) {
  390.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  391.         " arg ?arg ...?\"", (char *) NULL);
  392.     return TCL_ERROR;
  393.     }
  394.     if (argc == 2) {
  395.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  396.     } else {
  397.     
  398.     /*
  399.      * More than one argument:  concatenate them together with spaces
  400.      * between, then evaluate the result.
  401.      */
  402.     
  403.     cmd = Tcl_Concat(argc-1, argv+1);
  404.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  405.     ckfree(cmd);
  406.     }
  407.     if (result == TCL_ERROR) {
  408.     char msg[60];
  409.     sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
  410.     Tcl_AddErrorInfo(interp, msg);
  411.     }
  412.     return result;
  413. }
  414.  
  415. /*
  416.  *----------------------------------------------------------------------
  417.  *
  418.  * Tcl_ExprCmd --
  419.  *
  420.  *    This procedure is invoked to process the "expr" Tcl command.
  421.  *    See the user documentation for details on what it does.
  422.  *
  423.  * Results:
  424.  *    A standard Tcl result.
  425.  *
  426.  * Side effects:
  427.  *    See the user documentation.
  428.  *
  429.  *----------------------------------------------------------------------
  430.  */
  431.  
  432.     /* ARGSUSED */
  433. int
  434. Tcl_ExprCmd(dummy, interp, argc, argv)
  435.     ClientData dummy;            /* Not used. */
  436.     Tcl_Interp *interp;            /* Current interpreter. */
  437.     int argc;                /* Number of arguments. */
  438.     char **argv;            /* Argument strings. */
  439. {
  440.     if (argc != 2) {
  441.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  442.         " expression\"", (char *) NULL);
  443.     return TCL_ERROR;
  444.     }
  445.  
  446.     return Tcl_ExprString(interp, argv[1]);
  447. }
  448.  
  449. /*
  450.  *----------------------------------------------------------------------
  451.  *
  452.  * Tcl_ForCmd --
  453.  *
  454.  *    This procedure is invoked to process the "for" Tcl command.
  455.  *    See the user documentation for details on what it does.
  456.  *
  457.  * Results:
  458.  *    A standard Tcl result.
  459.  *
  460.  * Side effects:
  461.  *    See the user documentation.
  462.  *
  463.  *----------------------------------------------------------------------
  464.  */
  465.  
  466.     /* ARGSUSED */
  467. int
  468. Tcl_ForCmd(dummy, interp, argc, argv)
  469.     ClientData dummy;            /* Not used. */
  470.     Tcl_Interp *interp;            /* Current interpreter. */
  471.     int argc;                /* Number of arguments. */
  472.     char **argv;            /* Argument strings. */
  473. {
  474.     int result, value;
  475.  
  476.     if (argc != 5) {
  477.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  478.         " start test next command\"", (char *) NULL);
  479.     return TCL_ERROR;
  480.     }
  481.  
  482.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  483.     if (result != TCL_OK) {
  484.     if (result == TCL_ERROR) {
  485.         Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  486.     }
  487.     return result;
  488.     }
  489.     while (1) {
  490.     result = Tcl_ExprBoolean(interp, argv[2], &value);
  491.     if (result != TCL_OK) {
  492.         return result;
  493.     }
  494.     if (!value) {
  495.         break;
  496.     }
  497.     result = Tcl_Eval(interp, argv[4], 0, (char **) NULL);
  498.     if (result == TCL_CONTINUE) {
  499.         result = TCL_OK;
  500.     } else if (result != TCL_OK) {
  501.         if (result == TCL_ERROR) {
  502.         char msg[60];
  503.         sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
  504.         Tcl_AddErrorInfo(interp, msg);
  505.         }
  506.         break;
  507.     }
  508.     result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
  509.     if (result == TCL_BREAK) {
  510.         break;
  511.     } else if (result != TCL_OK) {
  512.         if (result == TCL_ERROR) {
  513.         Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  514.         }
  515.         return result;
  516.     }
  517.     }
  518.     if (result == TCL_BREAK) {
  519.     result = TCL_OK;
  520.     }
  521.     if (result == TCL_OK) {
  522.     Tcl_ResetResult(interp);
  523.     }
  524.     return result;
  525. }
  526.  
  527. /*
  528.  *----------------------------------------------------------------------
  529.  *
  530.  * Tcl_ForeachCmd --
  531.  *
  532.  *    This procedure is invoked to process the "foreach" Tcl command.
  533.  *    See the user documentation for details on what it does.
  534.  *
  535.  * Results:
  536.  *    A standard Tcl result.
  537.  *
  538.  * Side effects:
  539.  *    See the user documentation.
  540.  *
  541.  *----------------------------------------------------------------------
  542.  */
  543.  
  544.     /* ARGSUSED */
  545. int
  546. Tcl_ForeachCmd(dummy, interp, argc, argv)
  547.     ClientData dummy;            /* Not used. */
  548.     Tcl_Interp *interp;            /* Current interpreter. */
  549.     int argc;                /* Number of arguments. */
  550.     char **argv;            /* Argument strings. */
  551. {
  552.     int listArgc, i, result;
  553.     char **listArgv;
  554.  
  555.     if (argc != 4) {
  556.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  557.         " varName list command\"", (char *) NULL);
  558.     return TCL_ERROR;
  559.     }
  560.  
  561.     /*
  562.      * Break the list up into elements, and execute the command once
  563.      * for each value of the element.
  564.      */
  565.  
  566.     result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
  567.     if (result != TCL_OK) {
  568.     return result;
  569.     }
  570.     for (i = 0; i < listArgc; i++) {
  571.     if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
  572.         Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
  573.         result = TCL_ERROR;
  574.         break;
  575.     }
  576.  
  577.     result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
  578.     if (result != TCL_OK) {
  579.         if (result == TCL_CONTINUE) {
  580.         result = TCL_OK;
  581.         } else if (result == TCL_BREAK) {
  582.         result = TCL_OK;
  583.         break;
  584.         } else if (result == TCL_ERROR) {
  585.         char msg[100];
  586.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  587.             interp->errorLine);
  588.         Tcl_AddErrorInfo(interp, msg);
  589.         break;
  590.         } else {
  591.         break;
  592.         }
  593.     }
  594.     }
  595.     ckfree((char *) listArgv);
  596.     if (result == TCL_OK) {
  597.     Tcl_ResetResult(interp);
  598.     }
  599.     return result;
  600. }
  601.  
  602. /*
  603.  *----------------------------------------------------------------------
  604.  *
  605.  * Tcl_FormatCmd --
  606.  *
  607.  *    This procedure is invoked to process the "format" Tcl command.
  608.  *    See the user documentation for details on what it does.
  609.  *
  610.  * Results:
  611.  *    A standard Tcl result.
  612.  *
  613.  * Side effects:
  614.  *    See the user documentation.
  615.  *
  616.  *----------------------------------------------------------------------
  617.  */
  618.  
  619.     /* ARGSUSED */
  620. int
  621. Tcl_FormatCmd(dummy, interp, argc, argv)
  622.     ClientData dummy;            /* Not used. */
  623.     Tcl_Interp *interp;            /* Current interpreter. */
  624.     int argc;                /* Number of arguments. */
  625.     char **argv;            /* Argument strings. */
  626. {
  627.     register char *format;    /* Used to read characters from the format
  628.                  * string. */
  629.     char newFormat[40];        /* A _new format specifier is generated here. */
  630.     int width;            /* Field width from field specifier, or 0 if
  631.                  * no width given. */
  632.     int precision;        /* Field precision from field specifier, or 0
  633.                  * if no precision given. */
  634.     int size;            /* Number of bytes needed for result of
  635.                  * conversion, based on type of conversion
  636.                  * ("e", "s", etc.) and width from above. */
  637.     char *oneWordValue = NULL;    /* Used to hold value to pass to sprintf, if
  638.                  * it's a one-word value. */
  639.     double twoWordValue;    /* Used to hold value to pass to sprintf if
  640.                  * it's a two-word value. */
  641.     int useTwoWords;        /* 0 means use oneWordValue, 1 means use
  642.                  * twoWordValue. */
  643.     char *dst = interp->result;    /* Where result is stored.  Starts off at
  644.                  * interp->resultSpace, but may get dynamically
  645.                  * re-allocated if this isn't enough. */
  646.     int dstSize = 0;        /* Number of non-null characters currently
  647.                  * stored at dst. */
  648.     int dstSpace = TCL_RESULT_SIZE;
  649.                 /* Total amount of storage space available
  650.                  * in dst (not including null terminator. */
  651.     int noPercent;        /* Special case for speed:  indicates there's
  652.                  * no field specifier, just a string to copy. */
  653.     char **curArg;        /* Remainder of argv array. */
  654.  
  655.     /*
  656.      * This procedure is a bit nasty.  The goal is to use sprintf to
  657.      * do most of the dirty work.  There are several problems:
  658.      * 1. this procedure can't trust its arguments.
  659.      * 2. we must be able to provide a large enough result area to hold
  660.      *    whatever's generated.  This is hard to estimate.
  661.      * 2. there's no way to move the arguments from argv to the call
  662.      *    to sprintf in a reasonable way.  This is particularly nasty
  663.      *    because some of the arguments may be two-word values (doubles).
  664.      * So, what happens here is to scan the format string one % group
  665.      * at a time, making many individual calls to sprintf.
  666.      */
  667.  
  668.     if (argc < 2) {
  669.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  670.         " formatString ?arg arg ...?\"", (char *) NULL);
  671.     return TCL_ERROR;
  672.     }
  673.     curArg = argv+2;
  674.     argc -= 2;
  675.     for (format = argv[1]; *format != 0; ) {
  676.     register char *newPtr = newFormat;
  677.  
  678.     width = precision = useTwoWords = noPercent = 0;
  679.  
  680.     /*
  681.      * Get rid of any characters before the next field specifier.
  682.      * Collapse backslash sequences found along the way.
  683.      */
  684.  
  685.     if (*format != '%') {
  686.         register char *p;
  687.         int bsSize;
  688.  
  689.         oneWordValue = p = format;
  690.         while ((*format != '%') && (*format != 0)) {
  691.         if (*format == '\\') {
  692.             *p = Tcl_Backslash(format, &bsSize);
  693.             if (*p != 0) {
  694.             p++;
  695.             }
  696.             format += bsSize;
  697.         } else {
  698.             *p = *format;
  699.             p++;
  700.             format++;
  701.         }
  702.         }
  703.         size = p - oneWordValue;
  704.         noPercent = 1;
  705.         goto doField;
  706.     }
  707.  
  708.     if (format[1] == '%') {
  709.         oneWordValue = format;
  710.         size = 1;
  711.         noPercent = 1;
  712.         format += 2;
  713.         goto doField;
  714.     }
  715.  
  716.     /*
  717.      * Parse off a field specifier, compute how many characters
  718.      * will be needed to store the result, and substitute for
  719.      * "*" size specifiers.
  720.      */
  721.  
  722.     *newPtr = '%';
  723.     newPtr++;
  724.     format++;
  725.     while ((*format == '-') || (*format == '#')) {
  726.         *newPtr = *format;
  727.         newPtr++;
  728.         format++;
  729.     }
  730.     if (*format == '0') {
  731.         *newPtr = '0';
  732.         newPtr++;
  733.         format++;
  734.     }
  735.     if (isdigit(*format)) {
  736.         width = atoi(format);
  737.         do {
  738.         format++;
  739.         } while (isdigit(*format));
  740.     } else if (*format == '*') {
  741.         if (argc <= 0) {
  742.         goto notEnoughArgs;
  743.         }
  744.         if (Tcl_GetInt(interp, *curArg, &width) != TCL_OK) {
  745.         goto fmtError;
  746.         }
  747.         argc--;
  748.         curArg++;
  749.         format++;
  750.     }
  751.     if (width != 0) {
  752.         sprintf(newPtr, "%d", width);
  753.         while (*newPtr != 0) {
  754.         newPtr++;
  755.         }
  756.     }
  757.     if (*format == '.') {
  758.         *newPtr = '.';
  759.         newPtr++;
  760.         format++;
  761.     }
  762.     if (isdigit(*format)) {
  763.         precision = atoi(format);
  764.         do {
  765.         format++;
  766.         } while (isdigit(*format));
  767.     } else if (*format == '*') {
  768.         if (argc <= 0) {
  769.         goto notEnoughArgs;
  770.         }
  771.         if (Tcl_GetInt(interp, *curArg, &precision) != TCL_OK) {
  772.         goto fmtError;
  773.         }
  774.         argc--;
  775.         curArg++;
  776.         format++;
  777.     }
  778.     if (precision != 0) {
  779.         sprintf(newPtr, "%d", precision);
  780.         while (*newPtr != 0) {
  781.         newPtr++;
  782.         }
  783.     }
  784.     if (*format == 'l') {
  785.         format++;
  786.     }
  787.     *newPtr = *format;
  788.     newPtr++;
  789.     *newPtr = 0;
  790.     if (argc <= 0) {
  791.         goto notEnoughArgs;
  792.     }
  793.     switch (*format) {
  794.         case 'D':
  795.         case 'O':
  796.         case 'U':
  797.         *newPtr = tolower(*format);
  798.         newPtr[-1] = 'l';
  799.         newPtr++;
  800.         *newPtr = 0;
  801.         case 'd':
  802.         case 'o':
  803.         case 'u':
  804.         case 'x':
  805.         case 'X':
  806.         if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
  807.             != TCL_OK) {
  808.             goto fmtError;
  809.         }
  810.         size = 40;
  811.         break;
  812.         case 's':
  813.         oneWordValue = *curArg;
  814.         size = strlen(*curArg);
  815.         break;
  816.         case 'c':
  817.         if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
  818.             != TCL_OK) {
  819.             goto fmtError;
  820.         }
  821.         size = 1;
  822.         break;
  823.         case 'F':
  824.         newPtr[-1] = tolower(newPtr[-1]);
  825.         case 'e':
  826.         case 'E':
  827.         case 'f':
  828.         case 'g':
  829.         case 'G':
  830.         if (Tcl_GetDouble(interp, *curArg, &twoWordValue) != TCL_OK) {
  831.             goto fmtError;
  832.         }
  833.         useTwoWords = 1;
  834.         size = 320;
  835.         if (precision > 10) {
  836.             size += precision;
  837.         }
  838.         break;
  839.         case 0:
  840.         interp->result =
  841.             "format string ended in middle of field specifier";
  842.         goto fmtError;
  843.         default:
  844.         sprintf(interp->result, "bad field specifier \"%c\"", *format);
  845.         goto fmtError;
  846.     }
  847.     argc--;
  848.     curArg++;
  849.     format++;
  850.  
  851.     /*
  852.      * Make sure that there's enough space to hold the formatted
  853.      * result, then format it.
  854.      */
  855.  
  856.     doField:
  857.     if (width > size) {
  858.         size = width;
  859.     }
  860.     if ((dstSize + size) > dstSpace) {
  861.         char *newDst;
  862.         int newSpace;
  863.  
  864.         newSpace = 2*(dstSize + size);
  865.         newDst = (char *) ckalloc((unsigned) newSpace+1);
  866.         if (dstSize != 0) {
  867.         memcpy((VOID *) newDst, (VOID *) dst, dstSize);
  868.         }
  869.         if (dstSpace != TCL_RESULT_SIZE) {
  870.         ckfree(dst);
  871.         }
  872.         dst = newDst;
  873.         dstSpace = newSpace;
  874.     }
  875.     if (noPercent) {
  876.         memcpy((VOID *) dst+dstSize, (VOID *) oneWordValue, size);
  877.         dstSize += size;
  878.         dst[dstSize] = 0;
  879.     } else {
  880.         if (useTwoWords) {
  881.         sprintf(dst+dstSize, newFormat, twoWordValue);
  882.         } else {
  883.         sprintf(dst+dstSize, newFormat, oneWordValue);
  884.         }
  885.         dstSize += strlen(dst+dstSize);
  886.     }
  887.     }
  888.  
  889.     interp->result = dst;
  890.     if (dstSpace != TCL_RESULT_SIZE) {
  891.     interp->freeProc = (Tcl_FreeProc *) free;
  892.     } else {
  893.     interp->freeProc = 0;
  894.     }
  895.     return TCL_OK;
  896.  
  897.     notEnoughArgs:
  898.     interp->result = "not enough arguments for all format specifiers";
  899.     fmtError:
  900.     if (dstSpace != TCL_RESULT_SIZE) {
  901.     ckfree(dst);
  902.     }
  903.     return TCL_ERROR;
  904. }
  905.